home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / copyalloc.c < prev    next >
C/C++ Source or Header  |  1992-10-27  |  19KB  |  837 lines
  1.  /*    
  2.   * Allocation routines for feel
  3.   *
  4.   */
  5.  
  6. /* what we need to stay ahead*/
  7. #include "defs.h"
  8. #include "structs.h"
  9. #include "funcalls.h"
  10. #include "global.h"
  11. #include "allocate.h" 
  12. #include "error.h"
  13. #include "table.h"
  14.  
  15. /* other junk */
  16. #include "copy.h"
  17.  
  18. #ifndef DEFAULT_HEAP_SIZE
  19. #define DEFAULT_HEAP_SIZE (4*1024*1024)
  20. #endif
  21.  
  22. #ifndef DEFAULT_STACK_SPACE_SIZE
  23. #define DEFAULT_STACK_SPACE_SIZE (1*1024*1024)
  24. #endif
  25.  
  26. #define N_SLOTS_IN_CLASS N_SLOTS_IN_STRUCT(struct class_structure)
  27. #define N_SLOTS_IN_THREAD N_SLOTS_IN_STRUCT(struct thread_structure)
  28.  
  29. #define ROUNDTO 8
  30. #define ROUND_ADDR(x) ((((int)x)&(ROUNDTO-1))==0 ? x : x+(ROUNDTO-((int)x&(ROUNDTO-1))))
  31.  
  32. #ifdef NODEBUG
  33. #define FPRINTF_GC_BUG(x) 
  34. #define GC_BUG(x)
  35. #else
  36. #define GC_BUG(x) x
  37. #define FPRINTF_GC_BUG(x) fprintf x
  38. #endif
  39.  
  40. LispObject static_ints;
  41.  
  42. void runtime_initialise_allocator(LispObject *stacktop)
  43. {
  44.   static void initialise_stack_space(int);
  45.   extern void init_allocator(int);
  46.   extern int command_line_heap_size;
  47.   extern int command_line_stack_space_size;
  48.   extern int command_line_cons_percentage;
  49.   extern int command_line_cons_cut_off;
  50.  
  51.   int heap,stack_space;
  52.   
  53.   heap = (command_line_heap_size == 0
  54.             ? DEFAULT_HEAP_SIZE 
  55.             : command_line_heap_size);
  56.  
  57.   if (heap < 50)
  58.     heap=heap*1024*1024;
  59.  
  60.  
  61.   {
  62.     extern int command_line_cons_percentage;
  63.     extern int command_line_cons_cut_off;
  64.     
  65.     if (command_line_stack_space_size < 50)
  66.       command_line_stack_space_size = command_line_stack_space_size*1024*1024;
  67.  
  68.     stack_space = (command_line_stack_space_size == 0
  69.            ? DEFAULT_STACK_SPACE_SIZE
  70.            : command_line_stack_space_size);
  71.   }
  72.  
  73.   init_allocator(heap); 
  74.   initialise_stack_space(stack_space); 
  75.  
  76.   /* Really need a smarter way of doing these... --- like do them last */
  77.   add_root((LispObject *) &state_dynamic_env);
  78.   add_root(&state_last_continue);
  79.   add_root(&state_handler_stack);
  80.   add_root(&state_current_thread);
  81. }
  82.  
  83. char *allocate_space(LispObject *stacktop,int n)
  84. {
  85.   char* allocate_stack(LispObject *stacktop, int nbytes);  
  86.  
  87.   return allocate_stack(stacktop,n);
  88. }
  89.  
  90. void deallocate_space(LispObject*stacktop,char *addr,int siz)
  91. {
  92.   void deallocate_stack(LispObject *, char *, int);
  93.  
  94.   deallocate_stack(stacktop,addr,siz);
  95. }
  96. void runtime_initialise_collector(LispObject *stacktop)
  97. {
  98.  
  99. }
  100.  
  101. #define NOT_YET_DONE(name) \
  102. { fprintf(stderr,"%s: cannot alloc\n",name) ; return nil;}
  103.   
  104. LispObject Fn_cons(LispObject *stacktop)
  105. {
  106.   LispObject ans;
  107.  
  108.   ans = allocate_nbytes(stacktop+2,sizeof(struct cons_structure),TYPE_CONS); 
  109.   
  110.   lval_classof(ans)=Cons;
  111.   ans->CONS.car= *stacktop;
  112.   ans->CONS.cdr= *(stacktop+1);
  113.   
  114.   return ans;
  115. }
  116.  
  117. /* Optimised to allow easier code in a lot of places... */
  118. LispObject allocate_n_conses(LispObject *stacktop, int n)
  119. {    
  120.   LispObject xx;
  121.   int i;
  122. #ifdef NOWAY  
  123.   struct cons_structure *ptr;
  124.  
  125.   xx=allocate_cbytes(stacktop,n,sizeof(struct cons_structure),TYPE_CONS);
  126.   ptr= &(xx->CONS);
  127.   lval_classof(xx)=Cons;
  128.   ptr++;
  129.   for (i=1; i<n; i++)
  130.     {
  131.       ptr->header.class=Cons; /* XXX */
  132.       ptr->car=nil;    
  133.       (ptr[-1]).cdr=(LispObject)ptr;
  134.       ptr++;
  135.     }
  136.   
  137.   ptr[-1].cdr=nil;
  138.   return xx;
  139. #else
  140.   xx=nil;
  141.   for (i=0; i<n; i++)
  142.     {
  143.       xx=EUCALL_2(Fn_cons,nil,xx);
  144.     }
  145.       
  146.   return xx;
  147.  
  148. #endif
  149. }
  150.  
  151. LispObject allocate_n_envs(LispObject *stacktop, int n)
  152. {    
  153.   LispObject xx;
  154.   int i;
  155.   xx=0;
  156.   for (i=0; i< n; i++)
  157.     {
  158.       xx=allocate_env(stacktop,nil,nil,xx);
  159.     }
  160.  
  161.   return xx;
  162. }
  163.  
  164. LispObject allocate_class(LispObject *stacktop,LispObject class)
  165. {
  166.   LispObject ans;
  167.   int i;
  168.  
  169.   STACK_TMP(class);
  170.   if (class==NULL)
  171.     ans = allocate_nbytes(stacktop,sizeof(struct class_structure),TYPE_CLASS);
  172.   else 
  173.     ans = allocate_nbytes(stacktop,
  174.               sizeof(Object_t)+sizeof(LispObject)*class->CLASS.local_count,
  175.               TYPE_CLASS);
  176.   UNSTACK_TMP(class);
  177.   lval_classof(ans) = class;
  178.  
  179.   (ans->CLASS).name = unbound;
  180.   (ans->CLASS).superclasses = nil;
  181.   (ans->CLASS).subclasses = nil;
  182.   (ans->CLASS).slot_table = nil;
  183.   (ans->CLASS).slot_list = nil;
  184.   (ans->CLASS).direct_slot_list = nil;
  185.   (ans->CLASS).precedence = nil;
  186.   (ans->CLASS).local_count = 0;
  187.   
  188.   if (class!=NULL)
  189.     {
  190.       for (i=N_SLOTS_IN_CLASS ; i<class->CLASS.local_count ; i++)
  191.     slotref(ans,i) = nil;
  192.     }
  193.   return ans;
  194. }
  195.  
  196. LispObject allocate_instance(LispObject *stacktop,LispObject class)
  197. {
  198.   LispObject ans;
  199.   int i;
  200.  
  201.   STACK_TMP(class);
  202.  
  203.   ans=allocate_nbytes(stacktop,sizeof(Object_t)
  204.               +sizeof(LispObject)*class->CLASS.local_count,TYPE_INSTANCE);
  205.   UNSTACK_TMP(class);
  206.   lval_classof(ans)=class;
  207.  
  208.   for (i=0; i<class->CLASS.local_count; i++)
  209.     slotref(ans,i)=nil;
  210.  
  211.   return ans;
  212. }
  213.  
  214. LispObject allocate_thread(LispObject *stacktop,int stack_size, 
  215.                int gc_stack_size, int nslots)
  216. { 
  217.   char* allocate_stack(LispObject *stacktop, int nbytes);
  218.   /* xxx: need extra slots hack */
  219.   LispObject ans,cont;
  220.   int extra;
  221.  
  222.   extra=nslots>0? nslots-N_SLOTS_IN_THREAD: 0;
  223.   cont=allocate_continue(stacktop);
  224.   *stacktop=cont;
  225.   
  226.   
  227.   ans=allocate_nbytes(stacktop+1,
  228.               sizeof(struct thread_structure)+extra*sizeof(LispObject),
  229.               TYPE_THREAD);
  230.   cont = *stacktop;
  231.   *stacktop=ans;
  232.   lval_classof(ans) = Thread;
  233.  
  234.   (ans->THREAD).stack_size = stack_size;
  235.   (ans->THREAD).gc_stack_size = gc_stack_size;
  236.  
  237.   (ans->THREAD).fun = nil;
  238.   (ans->THREAD).args = nil;
  239.   (ans->THREAD).value = nil;
  240.  
  241.   (ans->THREAD).status = 0;
  242.  
  243.   (ans->THREAD).parent = nil;
  244.   (ans->THREAD).cochain = nil;
  245.   
  246.   (ans->THREAD).state = cont;
  247.   (ans->THREAD).stack_base = NULL;
  248.   (ans->THREAD).gc_stack_base = NULL;
  249.  
  250.   ans->THREAD.state->CONTINUE.thread=ans;
  251.  
  252. #ifdef MACHINE_ANY
  253.  
  254.   (ans->THREAD).stack_base = (int *) allocate_stack(stacktop+1,stack_size);
  255.   (ans->THREAD.state)->CONTINUE.gc_stack_pointer =
  256.     (ans->THREAD).gc_stack_base =
  257.       (LispObject *) allocate_stack(stacktop+1,gc_stack_size*sizeof(LispObject));
  258.   
  259.   fprintf(stderr,"{New stack: 0x%x->0x%x}", (ans->THREAD).gc_stack_base,
  260.        (ans->THREAD).gc_stack_base+gc_stack_size);
  261.   STACK_TMP(ans);
  262.   cont=EUCALL_2(Fn_cons,function_default_handler,nil);
  263.   UNSTACK_TMP(ans);
  264.   ans->THREAD.state->CONTINUE.handler_stack = cont;
  265.     
  266. #else
  267.  
  268.   ans->THREAD.stack_base = NULL;
  269.   ans->THREAD.gc_stack_base = NULL;
  270.   ans->THREAD.state->CONTINUE.gc_stack_pointer = NULL;
  271.   cont =  EUCALL_2(Fn_cons,function_default_handler,nil);
  272.  
  273.   ans->THREAD.state->CONTINUE.handler_stack = cont;
  274.  
  275.  
  276. #endif
  277.   { /* ugh */
  278.     int i;
  279.     if (extra>0)
  280.       for(i=N_SLOTS_IN_THREAD; i<nslots; i++)
  281.     slotref(ans,i) = unbound;
  282.   }
  283.   return ans;
  284. }
  285.  
  286. LispObject allocate_vector(LispObject *stacktop,int size)
  287. {
  288.   LispObject ans;
  289.   int i;
  290.  
  291.   ans = allocate_nbytes(stacktop,sizeof(Object_t)+sizeof(int)+size*sizeof(LispObject),
  292.             TYPE_VECTOR);
  293.   
  294.   lval_classof(ans)= Vector;
  295.   
  296.   ans->VECTOR.length=size;
  297.  
  298.   for(i=0; i<size ; i++)
  299.     vref(ans,i)=nil;
  300.  
  301.   return ans;
  302. }
  303.  
  304. LispObject allocate_string(LispObject *stacktop, char *string, int len)
  305. {
  306.   LispObject ans;
  307.  
  308.   len++;
  309.   len=ROUND_ADDR(len);
  310.   ans = allocate_nbytes(stacktop,sizeof(Object_t)+sizeof(int)+len,
  311.             TYPE_STRING); 
  312.   
  313.   lval_classof(ans)=String;
  314.   ans->STRING.length= len;
  315.   stringof(ans)[len-1]=0;
  316.   strncpy(stringof(ans),string,len);
  317.  
  318.   return ans;
  319. }
  320.  
  321. LispObject allocate_symbol(LispObject *stacktop, char *str)
  322. {
  323.   int hash(char *); /* from tables.c */
  324.  
  325.   int hv;
  326.   LispObject ans;
  327.   LispObject tmp,tmp2;
  328.   
  329.   tmp=allocate_string(stacktop,str,strlen(str));
  330.   STACK_TMP(tmp);
  331.   hv=hash(str);
  332.   tmp2=allocate_integer(stacktop,hv);
  333.   STACK_TMP(tmp2);
  334.   ans=allocate_nbytes(stacktop,sizeof(struct symbol_structure),TYPE_SYMBOL);
  335.   UNSTACK_TMP(tmp2);
  336.   UNSTACK_TMP(tmp);
  337.  
  338.   lval_classof(ans)=Symbol;
  339.   ans->SYMBOL.lvalue = nil;
  340.   ans->SYMBOL.lmodule = nil;
  341.   ans->SYMBOL.gvalue = NULL;
  342.   ans->SYMBOL.left = NULL;
  343.   ans->SYMBOL.right = NULL;
  344.   ans->SYMBOL.plist = nil;
  345.   ans->SYMBOL.hash = hv;
  346.   ans->SYMBOL.lhash = tmp2;
  347.   ans->SYMBOL.pname= tmp;
  348.  
  349.   return ans;
  350. }
  351.  
  352. LispObject allocate_table(LispObject *stacktop, LispObject (*comp)(LispObject*))
  353. {
  354.   LispObject ans;
  355.  
  356.   ans=allocate_nbytes(stacktop,sizeof(struct table_structure),TYPE_TABLE);
  357.   
  358.   lval_classof(ans)=Table;
  359.   (ans->TABLE).comparator = comp;
  360.   (ans->TABLE).lisp_comparator = nil;
  361.   (ans->TABLE).tree = nil;
  362.  
  363.   return ans;
  364. }
  365.  
  366. LispObject allocate_module_function(LispObject *stacktop,
  367.                     LispObject mod,LispObject name,
  368.                     LispObject (*fun)(LispObject*),
  369.                     int code)
  370. {
  371.   LispObject ans;
  372.  
  373.   STACK_TMP(name); STACK_TMP(mod);
  374.   ans=allocate_nbytes(stacktop,sizeof(struct c_function_structure),TYPE_C_FUNCTION);
  375.   UNSTACK_TMP(mod); UNSTACK_TMP(name);
  376.   lval_classof(ans) = Function;
  377.  
  378.   ans->C_FUNCTION.name = name;
  379.   ans->C_FUNCTION.home = mod;
  380.   ans->C_FUNCTION.argtype = code;
  381.   ans->C_FUNCTION.env = NULL;
  382.  
  383.   ans->C_FUNCTION.func = fun;
  384.   
  385.   return ans;
  386. }
  387.  
  388. #ifdef NOLOWTAGINTS
  389. LispObject real_allocate_integer(LispObject *stacktop, int n)
  390. {
  391.   LispObject ans;
  392.  
  393.   if (n>=0 && n<STATIC_INTEGERS)
  394.     return vref(static_ints,n);
  395.  
  396.   ans=allocate_nbytes(stacktop,sizeof(struct integer_structure),TYPE_INT);
  397.  
  398.   lval_classof(ans)=Integer;
  399.   intval(ans)=n;
  400.  
  401.   return ans;
  402. }
  403. #endif
  404.  
  405. /* stubs to keep arith.c happy */
  406. LispObject allocate_ratio(LispObject *stacktop,LispObject m,LispObject n)
  407. {
  408.   NOT_YET_DONE("ratio");
  409. }
  410.  
  411. LispObject allocate_complex(LispObject *stacktop,LispObject m,LispObject n)
  412. {
  413.   NOT_YET_DONE("complex");
  414. }
  415.  
  416. LispObject allocate_float(LispObject *stacktop,double x)
  417. {
  418.   LispObject ans;
  419.  
  420.   ans=allocate_nbytes(stacktop,sizeof(struct float_structure),TYPE_FLOAT);
  421.  
  422.   lval_classof(ans)=Real;
  423.   ans->FLOAT.fvalue=x;
  424.   
  425.   return ans;
  426.   
  427. }
  428.  
  429. LispObject allocate_char(LispObject *stacktop, char x)
  430. {
  431.   LispObject ans;
  432.  
  433.   ans=allocate_nbytes(stacktop,sizeof(struct character_structure),
  434.               TYPE_CHAR);
  435.   lval_classof(ans)=Character;
  436.   ans->CHAR.font=0;
  437.   ans->CHAR.code=x;
  438.   return ans;
  439.   
  440. }
  441.  
  442. LispObject allocate_continue(LispObject *stacktop)
  443. {
  444.  
  445.   LispObject ans;
  446.  
  447.   ans=allocate_nbytes(stacktop,sizeof(struct continue_structure),TYPE_CONTINUE);
  448.  
  449.   lval_classof(ans) = Continue;
  450.  
  451.   (ans->CONTINUE).thread = nil;
  452.  
  453.   (ans->CONTINUE).value = nil;
  454.   (ans->CONTINUE).target = nil;
  455.  
  456.   /*  (ans->CONTINUE).machine_state; */
  457.   (ans->CONTINUE).gc_stack_pointer = NULL;
  458.   (ans->CONTINUE).dynamic_env = NULL;
  459.   (ans->CONTINUE).last_continue = nil;
  460.   (ans->CONTINUE).handler_stack = nil;
  461.  
  462.   (ans->CONTINUE).dp = nil;
  463.  
  464.   (ans->CONTINUE).live = FALSE;
  465.   (ans->CONTINUE).unwind = FALSE;  
  466.   
  467.   return ans;
  468. }
  469.  
  470. LispObject allocate_stream(LispObject *stacktop, FILE *file, int mod)
  471. {
  472.   LispObject ans;
  473.  
  474.   ans = allocate_nbytes(stacktop,sizeof(struct stream_structure),TYPE_STREAM);
  475.  
  476.   lval_classof(ans) = Object;
  477.   (ans->STREAM).handle = file;
  478.   (ans->STREAM).name = nil; /* Wah? */
  479.   (ans->STREAM).mode = mod;
  480.   (ans->STREAM).curchar = 0;
  481.   return ans;
  482.  
  483. }
  484.  
  485. LispObject allocate_env(LispObject *stacktop, LispObject name, 
  486.             LispObject value, LispObject prev)
  487. {
  488.   LispObject ans;
  489.  
  490.   STACK_TMP(prev); STACK_TMP(name); STACK_TMP(value);
  491.   ans=allocate_nbytes(stacktop,sizeof(struct envobject),TYPE_ENV);
  492.   UNSTACK_TMP(value); UNSTACK_TMP(name); UNSTACK_TMP(prev);
  493.   lval_classof(ans) = nil; /* ? */
  494.  
  495.   ans->ENV.variable = name;
  496.   ans->ENV.value = value;
  497.   ans->ENV.next = &prev->ENV;
  498.   ans->ENV.mutable = lisptrue;
  499.  
  500.   return ans;
  501. }
  502.  
  503. LispObject allocate_envimut(LispObject *stacktop, LispObject name, LispObject value, LispObject prev)
  504. {
  505.   LispObject ans;
  506.   
  507.   ans=allocate_env(stacktop,name,value,prev);
  508.   
  509.   ans->ENV.mutable = nil;
  510.   return ans;
  511. }
  512.  
  513. LispObject allocate_special(LispObject *stacktop, 
  514.                 LispObject name, 
  515.                 LispObject (*fn)(LispObject *))
  516. {
  517.   LispObject ans;
  518.  
  519.   STACK_TMP(name);
  520.   ans=allocate_nbytes(stacktop,sizeof(struct special_structure),TYPE_SPECIAL);
  521.   UNSTACK_TMP(name);
  522.  
  523.   lval_classof(ans) = Object;
  524.  
  525.   ans->SPECIAL.name  = name;
  526.   ans->SPECIAL.env   = NULL;
  527.   ans->SPECIAL.func  = fn;
  528.  
  529.   return(ans);
  530.  
  531. }
  532.  
  533.  
  534. LispObject allocate_i_function(LispObject *stacktop, LispObject mod, 
  535.                    LispObject env, int argcode)
  536. {
  537.   LispObject ans;
  538.  
  539.   STACK_TMP(mod); STACK_TMP(env);
  540.   ans=allocate_nbytes(stacktop,sizeof(struct i_function_structure),TYPE_I_FUNCTION);
  541.  
  542.   UNSTACK_TMP(env); UNSTACK_TMP(mod);
  543.   lval_classof(ans)=Function;
  544.   ans->I_FUNCTION.name=nil;
  545.   ans->I_FUNCTION.home = mod;
  546.   ans->I_FUNCTION.env = &env->ENV;
  547.   ans->I_FUNCTION.argtype = argcode;
  548.   
  549.   ans->I_FUNCTION.bvl = nil;
  550.   ans->I_FUNCTION.body = nil;
  551.  
  552.   return ans;
  553. }
  554.  
  555.  
  556. LispObject allocate_i_module(LispObject *stacktop, LispObject name)
  557. {
  558.   LispObject ans;
  559.   LispObject tmp1,tmp2;
  560.   
  561.   STACK_TMP(name);
  562.   tmp1 = (LispObject) allocate_table(stacktop, Fn_eq);
  563.   STACK_TMP(tmp1);
  564.   tmp2 = (LispObject) allocate_table(stacktop, Fn_eq);    
  565.   STACK_TMP(tmp2);
  566.   ans=allocate_nbytes(stacktop,sizeof(struct i_module_structure), TYPE_I_MODULE);
  567.   UNSTACK_TMP(tmp2);
  568.   UNSTACK_TMP(tmp1);
  569.   UNSTACK_TMP(name);
  570.   lval_classof(ans)=Object;
  571.   ans->I_MODULE.name = name;
  572.   ans->I_MODULE.home = nil;
  573.   ans->I_MODULE.exported_names = nil;
  574.   ans->I_MODULE.bounce_flag = FALSE;
  575.   ans->I_MODULE.imported_modules = nil; /* HACK !!! GC */
  576.   ans->I_MODULE.bindings = tmp2;
  577.   
  578.   return ans;
  579. }
  580.  
  581. #if (defined(WITH_BSD_SOCKETS) || defined(WITH_SYSTEMV_SOCKETS))
  582.  
  583. LispObject allocate_listener(LispObject *stacktop)
  584. {
  585.   LispObject ans;
  586.  
  587.   ans=allocate_nbytes(stacktop,sizeof(struct listener_structure), TYPE_LISTENER);
  588.   lval_classof(ans)=nil; /* will be set later */
  589.   return ans;
  590. }
  591.  
  592.  
  593. LispObject allocate_socket(LispObject *stacktop)
  594. {
  595.   LispObject ans;
  596.   
  597.   ans=allocate_nbytes(stacktop,sizeof(struct socket_structure), TYPE_SOCKET);
  598.   lval_classof(ans)=nil; /* will be set later */
  599.   return ans;
  600. }
  601. #endif
  602.  
  603. LispObject allocate_semaphore(LispObject *stacktop)
  604. {
  605.   LispObject ans;
  606.   
  607.   ans=allocate_nbytes(stacktop,sizeof(struct semaphore_structure), TYPE_SEMAPHORE);
  608.  
  609.   lval_classof(ans)=Object; /* Ugh */
  610.   system_allocate_semaphore(&(ans->SEMAPHORE.semaphore));
  611.  
  612.   return ans;
  613. }
  614.  
  615. LispObject allocate_static_vector(LispObject *stacktop,int nslots)
  616. {
  617.   LispObject space;
  618.   int i;
  619.  
  620.   space=(LispObject) allocate_space(stacktop,sizeof(Object_t)+sizeof(int)+nslots*sizeof(LispObject));
  621.   
  622.   for (i=0; i<nslots; i++)
  623.     vref(space,i)=NULL;
  624.  
  625.   lval_typeof(space)=TYPE_VECTOR|STATIC_TYPE;
  626.   lval_classof(space)=Vector;
  627.   gcof(space)=current_space();
  628.   space->VECTOR.length=nslots;
  629.  
  630.   return(space);
  631. }
  632.  
  633. /* These are never called */
  634. void deallocate_page(LispObject *stacktop, char *addr, int n)
  635. {
  636.   
  637. }
  638.  
  639. LispObject show_free_heap(LispObject *stacktop)
  640. {
  641.  
  642. }
  643.  
  644. LispObject show_free_space(LispObject *stacktop)
  645. {
  646.  
  647. }
  648.  
  649. void promote_free_space(LispObject *stacktop)
  650. {
  651.  
  652. }
  653.  
  654.  
  655. void allocate_static_integers(LispObject *stacktop)
  656. {
  657. #ifdef NOLOWTAGINTS
  658.   int i;
  659.  
  660.   static_ints=allocate_static_vector(stacktop,STATIC_INTEGERS);
  661.   for (i=0; i<STATIC_INTEGERS; i++)
  662.     {        /* alloc a big integer, then 'fix' it */
  663.       LispObject xx=real_allocate_integer(stacktop,STATIC_INTEGERS);
  664.       intval(xx)=i;
  665.       vref(static_ints,i)=xx;
  666.     }
  667.  
  668.   add_root(&static_ints);
  669. #endif
  670. }
  671.  
  672.  
  673. typedef struct free_list_struct
  674. {
  675.   int size;
  676.   struct free_list_struct *next;
  677. } *FreeList;
  678.  
  679. static SYSTEM_GLOBAL(FreeList, stack_chain);
  680.  
  681. static int free_count;
  682. static int nfrags;
  683.  
  684. void initialise_stack_space(int stackspace)
  685. {
  686.   char *space=system_malloc(stackspace);
  687.   
  688.   SYSTEM_INITIALISE_GLOBAL(FreeList,stack_chain,NULL);
  689.   SYSTEM_GLOBAL_VALUE(stack_chain) = (FreeList) space;
  690.   
  691.   SYSTEM_GLOBAL_VALUE(stack_chain)->size= stackspace - sizeof(*SYSTEM_GLOBAL_VALUE(stack_chain));
  692.   SYSTEM_GLOBAL_VALUE(stack_chain)->next= NULL;
  693.   free_count=SYSTEM_GLOBAL_VALUE(stack_chain)->size;
  694.   nfrags=1;
  695. }
  696.  
  697. void show_stack_space()
  698. {
  699.   fprintf(stderr,"Stack space: %d remaining, %d fragments\n",free_count, nfrags);
  700. }
  701.  
  702. /* use header as pointer to prevously allocated stack */
  703.  
  704. char* allocate_stack(LispObject *stacktop, int nbytes)
  705. {
  706.   FreeList oldstack;
  707.   FreeList *walker;
  708.   char *ret;
  709.  
  710.   if (nbytes==0)
  711.     return NULL;
  712.  
  713.   system_open_semaphore(stacktop,&S_G_V(GC_sem)); 
  714.   walker= &SYSTEM_GLOBAL_VALUE(stack_chain);
  715.   nbytes=ROUND_ADDR(nbytes);
  716.  
  717.   free_count -= nbytes;
  718.  
  719.   while ( (*walker)!=NULL)
  720.     {
  721.       if ((*walker)->size+sizeof(*walker)==nbytes)
  722.     { 
  723.       ret= (char*) (*walker);
  724.       *walker=(*walker)->next;
  725.       nfrags--;
  726.       FPRINTF_GC_BUG((stderr,"{Cool stack: %x->%x}",ret,ret+nbytes));
  727.       GC_BUG(memset(ret,'S',nbytes));
  728.       system_close_semaphore(&S_G_V(GC_sem)); 
  729.       return ret;
  730.     }
  731.       if ((*walker)->size<nbytes)
  732.     {
  733.       FPRINTF_GC_BUG((stderr,"[Looking at: %x->%x (%d)]",*walker,(*walker)+(*walker)->size,
  734.               (*walker)->size));      
  735.       walker = &((*walker)->next);
  736.     }
  737.       else
  738.     {
  739.       ret= ((char *)((*walker)+1))+((*walker)->size-nbytes);
  740.       (*walker)->size=(*walker)->size-nbytes;
  741.       GC_BUG(memset(ret,'S',nbytes));
  742.       FPRINTF_GC_BUG((stderr,"{Alloc stack: %x->%x}",ret,ret+nbytes));
  743.       system_close_semaphore(&S_G_V(GC_sem)); 
  744.       return ret;
  745.     }
  746.     }
  747.   fprintf(stderr,"alloc stack: stack wimped out (%d remaining --- probably)\n",free_count);
  748.   system_close_semaphore(&S_G_V(GC_sem)); 
  749.   return NULL;
  750. }
  751.  
  752. void deallocate_stack(LispObject *stacktop, char *addr,int nbytes)
  753. {
  754.   FreeList old, walker;
  755.   /* Too damm lazy */
  756.   nbytes=ROUND_ADDR(nbytes);
  757.  
  758.   
  759.   system_open_semaphore(stacktop,&S_G_V(GC_sem)); 
  760.   walker=SYSTEM_GLOBAL_VALUE(stack_chain);
  761.   FPRINTF_GC_BUG((stderr,"{dealloc: %x->%x [%d]",addr,addr+nbytes,nbytes));
  762.   while (   ((char *)walker->next) < addr
  763.      && walker->next!=NULL)
  764.     {
  765.       /* sanity check */
  766.       if (walker >= walker->next)
  767.     { 
  768.       FPRINTF_GC_BUG((stderr,"Rats--- strange chain\n"));
  769.       system_lisp_exit(1);
  770.     }
  771.       walker=walker->next;
  772.     }
  773.   /* 3 cases --- at the start */
  774.   if ( ((char *)(walker+1)) + walker->size == addr)
  775.     {
  776.       /* side check for end */
  777.  
  778.       if (walker->next!=NULL && addr+nbytes == (char *) walker->next)
  779.     {
  780.       walker->size = walker->size+nbytes
  781.         +sizeof(*walker)
  782.           +walker->next->size;
  783.       walker->next=walker->next->next;
  784.       free_count+=nbytes+sizeof(*walker);
  785.       nfrags--;
  786.       FPRINTF_GC_BUG((stderr,"Filler}"));
  787.     }
  788.       else    
  789.     {
  790.       walker->size=walker->size+nbytes;
  791.       free_count+=nbytes;
  792.       FPRINTF_GC_BUG((stderr,"Start}"));
  793.     }
  794.       system_close_semaphore(&S_G_V(GC_sem)); 
  795.       return;
  796.     }
  797.   /* at the end */
  798.   if ( walker->next!=NULL && addr+nbytes == (char *) walker->next)
  799.     {
  800.       old=walker->next;
  801.       walker->next=(FreeList) addr;
  802.       walker->next->size=nbytes+old->size;
  803.       walker->next->next=old->next;
  804.       free_count+=nbytes;
  805.       FPRINTF_GC_BUG((stderr,"End}"));
  806.       system_close_semaphore(&S_G_V(GC_sem)); 
  807.       return;
  808.     }
  809.   /* in the middle */
  810.   old=walker->next;      
  811.   walker->next=(FreeList) addr;
  812.   walker->next->next=old;
  813.   walker->next->size=nbytes-sizeof(*walker);
  814.   nfrags++;
  815.   free_count+=nbytes-sizeof(*walker);
  816.   FPRINTF_GC_BUG((stderr,"Middle}"));
  817.   system_close_semaphore(&S_G_V(GC_sem)); 
  818. }
  819.   
  820. int dump_obj(unsigned int *x,int s)
  821. {
  822.   int i;
  823.   
  824.   if (s>200) s=16;
  825.  
  826.   for (i=0; i<s ; i+=4)
  827.     fprintf(stderr,"0x%x: %x %x %x %x\n",
  828.         x+i,
  829.         (int)*(x+i),(int)*(x+i+1),(int)*(x+i+2),(int)*(x+i+3));
  830.   return s;
  831. }
  832.   
  833.  
  834.  
  835.  
  836.  
  837.